home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / COMAL / cboot.d64 / plot'char.lst < prev    next >
File List  |  2009-01-23  |  2KB  |  108 lines
  1. 4000 // EDIT "PLOT'CHAR.LST"
  2. 4010 DIM DUMMY$ OF 25 // SPACE FOR SUB
  3. 4020 BUILD'SUB
  4. 4030 END 
  5. 4040 PROC PLOT'CHAR(X,Y,C$,C'SET) CLOSED
  6. 4050 IF Y<7 OR Y>199 OR X<0 OR X>312 THEN GOTO EXIT
  7. 4060 IY:=199-INT(Y)
  8. 4070 P:=INT(X) MOD 8
  9. 4080 TWO'TO'P:=2^P; TWO'P'8:=2^(8-P)
  10. 4090 S:=7-(IY MOD 8)
  11. 4100 COLOR:=PEEK(53281)-240+16*PEEK(646)
  12. 4110 C'CD:=ORD(C$)
  13. 4120 IF C'CD=255 THEN C'CD:=126
  14. 4130 CASE (C'CD DIV 32) OF
  15. 4140 WHEN 0,4
  16. 4150 C'CD:=32
  17. 4160 WHEN 2,5,7
  18. 4170 C'CD:=C'CD-64
  19. 4180 WHEN 3
  20. 4190 C'CD:=C'CD-32
  21. 4200 WHEN 6
  22. 4210 C'CD:=C'CD-128
  23. 4220 OTHERWISE 
  24. 4230 ENDCASE 
  25. 4240 CASE C'SET OF
  26. 4250 WHEN 0
  27. 4260 BASE:=53248
  28. 4270 WHEN 1
  29. 4280 BASE:=54272
  30. 4290 WHEN 2
  31. 4300 BASE:=55296
  32. 4310 WHEN 3
  33. 4320 BASE:=56320
  34. 4330 OTHERWISE 
  35. 4340 ENDCASE 
  36. 4350 C'ADDR:=8*C'CD+BASE
  37. 4360 DIS'INT
  38. 4370 I'O:=PEEK(1)
  39. 4380 POKE 1,8*(I'O DIV 8)+(I'O MOD 4)
  40. 4390 CA:=C'ADDR; R:=IY
  41. 4400 CBA:=COLOR'BYTE'ADDR(X,R)
  42. 4410 POKE CBA,COLOR
  43. 4420 IF P<>0 THEN
  44. 4430 POKE CBA+1,COLOR
  45. 4440 ENDIF 
  46. 4450 WHILE R<=IY+S DO
  47. 4460 DOTS:=PEEK(CA)
  48. 4470 CBA:=CELL'BYTE'ADDR(X,R)
  49. 4480 LB:=DOTS DIV TWO'TO'P
  50. 4490 AND'BYTE(CBA,LB)
  51. 4500 IF P<>0 THEN
  52. 4510 RB:=TWO'P'8*(DOTS-LB*TWO'TO'P)
  53. 4520 AND'BYTE(CBA+8,RB)
  54. 4530 ENDIF 
  55. 4540 CA:=CA+1; R:=R+1
  56. 4550 ENDWHILE 
  57. 4560 IF S<=7 THEN
  58. 4570 CBA:=COLOR'BYTE'ADDR(X,R)
  59. 4580 POKE CBA,COLOR
  60. 4590 IF P<>0 THEN
  61. 4600 POKE CBA+1,COLOR
  62. 4610 ENDIF 
  63. 4620 WHILE R<=IY+7 DO
  64. 4630 DOTS:=PEEK(CA)
  65. 4640 CBA:=CELL'BYTE'ADDR(X,R)
  66. 4650 LB:=DOTS DIV TWO'TO'P
  67. 4660 AND'BYTE(CBA,LB)
  68. 4670 IF P<>0 THEN
  69. 4680 RB:=TWO'P'8*(DOTS-LB*TWO'TO'P)
  70. 4690 AND'BYTE(CBA+8,RB)
  71. 4700 ENDIF 
  72. 4710 CA:=CA+1; R:=R+1
  73. 4720 ENDWHILE 
  74. 4730 ENDIF 
  75. 4740 POKE 1,PEEK(1)+4
  76. 4750 ENA'INT
  77. 4760 EXIT:
  78. 4770 ENDPROC PLOT'CHAR
  79. 4780 FUNC CELL'BYTE'ADDR(X,IY) CLOSED
  80. 4790 RETURN 57344+320*(IY DIV 8)+8*(X DIV 8)+(IY MOD 8)
  81. 4800 ENDFUNC CELL'BYTE'ADDR
  82. 4810 FUNC COLOR'BYTE'ADDR(X,IY) CLOSED
  83. 4820 RETURN 55296+40*(IY DIV 8)+X DIV 8
  84. 4830 ENDFUNC COLOR'BYTE'ADDR
  85. 4840 PROC DIS'INT CLOSED
  86. 4850 POKE 56334,2*(PEEK(56334) DIV 2)
  87. 4860 ENDPROC DIS'INT
  88. 4870 PROC ENA'INT CLOSED
  89. 4880 POKE 56334,PEEK(56334)+1
  90. 4890 ENDPROC ENA'INT
  91. 4900 PROC AND'BYTE(ADDR,BYTE) CLOSED
  92. 4910 POKE 251,(ADDR MOD 256)
  93. 4920 POKE 252,(ADDR DIV 256)
  94. 4930 POKE 253,BYTE
  95. 4940 SYS 45031
  96. 4950 ENDPROC AND'BYTE
  97. 4960 PROC BUILD'SUB CLOSED
  98. 4970 B:=45031
  99. 4980 FOR A:=B TO B+24 DO
  100. 4990 READ N
  101. 5000 POKE A,N
  102. 5010 ENDFOR A
  103. 5020 DATA 120,165,1,133,254,41,249
  104. 5030 DATA 9,1,133,1,160,0,177,251
  105. 5040 DATA 5,253,145,251
  106. 5050 DATA 165,254,133,1,88,96
  107. 5060 ENDPROC BUILD'SUB
  108.